home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / SmallTalk / Metaclass.st < prev    next >
Text File  |  1995-08-25  |  9KB  |  290 lines
  1. "======================================================================
  2. |
  3. |   MetaClass Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbyrne     16 May 90      Changed the implementation of name: ... to try to
  36. |              preserve an existing class (if possible).  The
  37. |              original code exists in newMeta: ...
  38. |
  39. | sbyrne     25 Apr 89      created.
  40. |
  41. "
  42.  
  43. ClassDescription subclass: #Metaclass
  44.          instanceVariableNames: 'instanceClass'
  45.          classVariableNames: ''
  46.          poolDictionaries: ''
  47.          category: nil
  48. !
  49.  
  50. Metaclass comment: 
  51. 'I am the root of the class hierarchy.  My instances are metaclasses, one for
  52. each real class.  My instances have a single instance, which they hold
  53. onto, which is the class that they are the metaclass of.  I provide methods
  54. for creation of actual class objects from metaclass object, and the creation
  55. of metaclass objects, which are my instances.  If this is confusing to you,
  56. it should be...the Smalltalk metaclass system is strange and complex.' !
  57.  
  58. !Metaclass class methodsFor: 'instance creation'!
  59.  
  60. subclassOf: superMeta
  61.     | newMeta |
  62.     newMeta _ self new.
  63.     newMeta superclass: superMeta.
  64.     superMeta addSubclass: newMeta.
  65.     newMeta initMetaclass.
  66.     ^newMeta
  67.  
  68. !!
  69.  
  70.  
  71.  
  72. !Metaclass methodsFor: 'basic'!
  73.  
  74. name: newName
  75.     environment: aSystemDictionary
  76.     subclassOf: superclass
  77.     instanceVariableNames: stringOfInstVarNames
  78.     variable: variableBoolean
  79.     words: wordBoolean
  80.     pointers: pointerBoolean
  81.     classVariableNames: stringOfClassVarNames
  82.     poolDictionaries: stringOfPoolNames
  83.     category: categoryName
  84.     comment: commentString
  85.     changed: changed
  86.     | aClass variableString variableArray sharedPoolNames poolName pool 
  87.       className classVarDict oldClassPool |
  88.  
  89.     "Please don't look at this case for an example of how to create good 
  90.      Smalltalk code.  It is inelegantly written and probably highly 
  91.     inefficient."
  92.  
  93.     className _ newName asSymbol.
  94.     aClass _ aSystemDictionary at: className ifAbsent: [ nil ].
  95.     aClass isNil
  96.     ifTrue: [ ^self newMeta: newName
  97.             environment: aSystemDictionary
  98.             subclassOf: superclass
  99.             instanceVariableNames: stringOfInstVarNames
  100.             variable: variableBoolean
  101.             words: wordBoolean
  102.             pointers: pointerBoolean
  103.             classVariableNames: stringOfClassVarNames
  104.             poolDictionaries: stringOfPoolNames
  105.             category: categoryName
  106.             comment: commentString
  107.             changed: changed ].
  108.  
  109.     (aClass isVariable == variableBoolean)
  110.     & (aClass isWords == wordBoolean )
  111.     & (aClass isPointers == pointerBoolean)
  112.     ifFalse: [ ^self newMeta: newName
  113.               environment: aSystemDictionary
  114.               subclassOf: superclass
  115.               instanceVariableNames: stringOfInstVarNames
  116.               variable: variableBoolean
  117.               words: wordBoolean
  118.               pointers: pointerBoolean
  119.               classVariableNames: stringOfClassVarNames
  120.               poolDictionaries: stringOfPoolNames
  121.               category: categoryName
  122.               comment: commentString
  123.               changed: changed ].
  124.  
  125.     "Here we have an existing class, so try hard to leave it alone"
  126.     instanceClass _ aClass.
  127.     aClass setSuperclass: superclass.
  128.     " Fix up meta class link also "
  129.     superclass notNil
  130.     ifTrue: [ aClass class setSuperclass: superclass class ].
  131.  
  132.     superclass notNil 
  133.     ifTrue: [ "Inherit instance variables from parent"
  134.               variableString _ superclass instanceVariableString
  135.           ]
  136.         ifFalse: [ variableString _ '' ].
  137.     variableString _ variableString , stringOfInstVarNames.
  138.     variableArray _ self parseVariableString: variableString.
  139.     1 to: variableArray size do:
  140.         [ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
  141.     variableArray = aClass allInstVarNames
  142.     ifFalse: [ stdout nextPutAll: 'Recompilation required!'; nl.
  143.            "aClass compileAll.
  144.            aClass compileAllSubclasses."
  145.            "### This should be fixed soon" ].
  146.     aClass setInstanceVariables: variableArray.
  147.  
  148.     aClass setInstanceSpec: variableBoolean words: wordBoolean
  149.         pointers: pointerBoolean instVars: variableArray size.
  150.  
  151.     classVarDict _ (self parseToDict: stringOfClassVarNames).
  152.     oldClassPool _ aClass classPool.
  153.     oldClassPool isNil 
  154.     ifTrue: [ aClass setClassVariables: classVarDict ]
  155.     ifFalse: [ classVarDict associationsDo:
  156.                [ :assoc | (oldClassPool includesKey: assoc key)
  157.                       ifFalse: 
  158.                       [ aClass addClassVarName: 
  159.                         assoc key ] ] ].
  160.     classVarDict keys  ~= aClass classPool keys
  161.     ifTrue: [ stdout nextPutAll:
  162.               'Recompilation required: different class variables!';
  163.                         nl ].
  164.  
  165.     sharedPoolNames _ self parseVariableString: stringOfPoolNames.
  166.     1 to: sharedPoolNames size do:
  167.         [ :i | poolName _ (sharedPoolNames at: i) asSymbol.
  168.                "### Check that the pool name starts with an uppercase letter
  169.         here."
  170.            "??? Should this create the pool if not there?"
  171.            pool _ aSystemDictionary
  172.                        at: poolName
  173.                        ifAbsent: [ ^self error: 'Pool name ', poolName ,
  174.                                      ' does not exist' ].
  175.               sharedPoolNames at: i put: pool ].
  176.     "### probably should check for recompilation required here in case
  177.      the intersection of the sets of pool dictionaries shrinks"
  178.     aClass setSharedPools: sharedPoolNames.
  179.  
  180.     "### not done"
  181.     aClass category: categoryName. "### need to remove the old category maybe"
  182.     "### don't know what to do with changed"
  183.     "### Need to update existing meta class (if there is one) -- change
  184.      its superclass, and fixup its old superclass to not refer to it
  185.      anymore"
  186.     ^aClass
  187. !
  188.  
  189.  
  190. newMeta: newName
  191.     environment: aSystemDictionary
  192.     subclassOf: superclass
  193.     instanceVariableNames: stringOfInstVarNames
  194.     variable: variableBoolean
  195.     words: wordBoolean
  196.     pointers: pointerBoolean
  197.     classVariableNames: stringOfClassVarNames
  198.     poolDictionaries: stringOfPoolNames
  199.     category: categoryName
  200.     comment: commentString
  201.     changed: changed
  202.     | aClass variableString variableArray sharedPoolNames poolName pool |
  203.  
  204.     sharedPoolNames _ self parseVariableString: stringOfPoolNames.
  205.     1 to: sharedPoolNames size do:
  206.         [ :i | poolName _ (sharedPoolNames at: i) asSymbol.
  207.            (poolName at: 1) isUppercase
  208.            ifFalse: [ ^self error: 'Pool name ', poolName,
  209.                   ' does not begin with an uppercase letter' ].
  210.            pool _ aSystemDictionary at: poolName
  211.                        ifAbsent: [ ^self error: 'Pool name ', poolName ,
  212.                     ' does not exist' ].
  213.               sharedPoolNames at: i put: pool ].
  214.     aClass _ self new.
  215.     instanceClass _ aClass.
  216.     aSystemDictionary at: (newName asSymbol) put: aClass.
  217.     aClass superclass: superclass.
  218.     aClass setName: newName asSymbol.
  219.     superclass notNil
  220.         ifTrue: [ superclass addSubclass: aClass.
  221.                   "Inherit instance variables from parent"
  222.               variableString _ superclass instanceVariableString
  223.           ]
  224.         ifFalse: [ variableString _ '' ].
  225.     variableString _ variableString , stringOfInstVarNames.
  226.     variableArray _ self parseVariableString: variableString.
  227.     1 to: variableArray size do:
  228.         [ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
  229.     aClass setInstanceVariables: variableArray.
  230.     aClass setInstanceSpec: variableBoolean words: wordBoolean
  231.         pointers: pointerBoolean instVars: variableArray size.
  232.     aClass setClassVariables: (self parseToDict: stringOfClassVarNames).
  233.     aClass setSharedPools: sharedPoolNames.
  234.     "### not done"
  235.     aClass category: categoryName.
  236.     aClass comment: commentString.
  237.     "### don't know what to do with changed"
  238.     "### Need to update existing meta class (if there is one) -- change
  239.      its superclass, and fixup its old superclass to not refer to it
  240.      anymore"
  241.     ^aClass
  242. !!
  243.  
  244.  
  245.  
  246. !Metaclass methodsFor: 'accessing'!
  247.  
  248. instanceClass
  249.     ^instanceClass
  250. !!
  251.  
  252.  
  253.  
  254.  
  255. !Metaclass methodsFor: 'printing'!
  256.  
  257. printOn: aStream
  258.     instanceClass printOn: aStream.
  259.     aStream nextPutAll: ' class'
  260. !
  261.  
  262. storeOn: aStream
  263.     self printOn: aStream
  264. !!
  265.  
  266.  
  267.  
  268. !Metaclass methodsFor: 'private'!
  269.  
  270. initMetaclass
  271.     instanceVariables _ Class allInstVarNames.
  272.     instanceSpec _ Class instanceSpec
  273. !
  274.  
  275. parseVariableString: aString
  276.     | stream |
  277.     stream _ TokenStream on: aString.
  278.     ^stream contents
  279. !
  280.  
  281. parseToDict: aString
  282.     | tokenArray dict |
  283.     tokenArray _ self parseVariableString: aString.
  284.     dict _ Dictionary new.
  285.     tokenArray do:
  286.         [ :element | dict at: element asSymbol put: nil ].
  287.     ^dict
  288.  
  289. !!
  290.